Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostuf/vr.pas

Pascal/Delphi Source File | 1994-07-25 | 17.3 KB | 968 lines

program virtual_reality;
{
    Virtual Reality #1
    - by Bjarke Viksφe
    apr 1994

  THIS PROGRAM WAS CODED BY BJARKE VIKS0E.
  YOU ARE FREE TO DO WHATEVER YOU WANT WITH THIS PIECE OF CODE.
  E-MAIL ME AT: [e-mail] IN 1994 FOR CHAT AND CODE.

    Pass LABYRINT.TXT as parameters (in the RUN/-menu) and make sure that
    the file is in the current directory...

    No texture-mapped walls. Could be easily added. Simply store
    some y-values along with colors...
    But the whole concept seem to have been misunderstood. As I
    figure it, Doom and the likes use some devious ray-casting scheme
    to create walls.
    This program uses a much more simplyfied way of making walls. Simply
    rotate all walls. See if they are within eye-range. Paint them one
    by one using painter's-algorithm in reverse (starting with nearest one).

    Walls are copied to a buffer and when done, the whole lot is copied
    quickly to the screen. This is actually a great deal faster that doing
    screen-writes at once (because I don't do word-writes I guess!).

}

{$A+,B-,G+,E+,I+,N-,X+}

uses
    DEMOINIT,MOUSE{,TEXT1};


(*{$DEFINE DEBUG}*)

const
    MOUSE_CONTROL = TRUE;

    {Plade sizes}
    MAX = 10;
    {Box definitions}
    HEIGHT = 120;
    MIDDLE_X = 160;
    MIDDLE_Y = HEIGHT DIV 2;
    {Colors}
    floor_color = 194;
    sky_color = 195;
    yellow1_color = 190;
    yellow2_color = 191;
    red1_color = 192;
    red2_color = 193;
    {Coord consts}
    MAXZ = 7000;
    BOXX = 150;
    BOXY = 100;
    BOXZ = BOXX;

type
    pKasse = ^kassetype;
    kassetype = RECORD
        x,z : integer;
        newx,newz : integer;
        f1,f2,f3,f4 : boolean;
    end;
    kassetabel = array[0..441] of pKasse;

    booktabel = array[0..320] of integer; {tabel for book-keeping}

    pDispBuffer = ^dispbuffertype;
    dispbuffertype = array[0..WIDTH*HEIGHT] of byte;


var
    v : word;
    vinkel1,vinkel2 : integer;
    sintabel : array [0..639] of integer;

    speedx,speedz : integer;
    worldx,worldz : integer;
    mousex,mousey : integer;

    tabel : booktabel;
    paint : booktabel;
    color : booktabel;

    plade : array[-MAX..MAX] of string[21];

    count : integer; {kasser ialt}
    antal : integer; {kasser tilbage efter beregninger...}

    alle_kasser : array[-MAX..MAX,1..22] of pKasse;
    kasser : kassetabel;
    synlige_kasser : kassetabel;

    dispbuffer : pDispBuffer;

const
    display1 : word = $0000;
    display2 : word = $4000;
    display3 : word = $8000;

procedure RotateCoord(x,y,z : integer; VAR rx,ry,rz : integer); forward;
procedure RotateKasse(x,z : integer; VAR rx,rz : integer); forward;
function WhereX(x : integer) : integer; forward;
function WhereZ(z : integer) : integer; forward;



(*------------------------------------------------*)

procedure SetPlot(x,y,size,color : integer);
var
    i,j : integer;
begin
    for i:=0 to size do for j:=0 to size do
        SetPixel(display2,x+i,y+j,color);
end;

procedure DrawBigHelpScreen;
var
    x,y : integer;
    i,j,k : integer;
begin
    for i:=-MAX to MAX do begin
        for j:=1 to 21 do if plade[i,j]='*' then begin
            x:=160+(i*5);
            y:=82+((j-MAX)*5);
            SetPlot(x,y,4,red2_color);
            SetPlot(x+1,y+1,2,red1_color);
        end;
    end;
    x:=160-((WhereX(-worldz)+1)*5);
    y:=82-(WhereZ(-worldx)*5);
    SetPlot(x+1,y+1,2,yellow1_color);
    SetPlot(x+2,y+2,0,yellow2_color);

    Key:=#0;
    while Key=#0 do ;
    Key:=#0;
    SetMousePos(160,100);
end;

(*------------------------------------------------*)

procedure SystemCheck;
begin
    if NOT MouseDriverPresent then begin
        writeln;
        writeln('ERROR: Needs mouse-driver.');
        writeln;
        halt;
    end;
    if (ParamCount<>1) then begin
        writeln;
        writeln('USAGE: BONUS.EXE <FILENAME OF LABYRINTH-TEXTFILE>');
        writeln;
        halt;
    end;
    if (Test8086<2) then begin
        writeln;
        writeln('ERROR: Needs at least a ''386!');
        writeln;
        halt;
    end;
end;


procedure SetupSinus;
var
    i : integer;
    v, vadd : real;
begin
    v:=0.0;
    vadd:=(2.0*pi/512.0);
    for i:=0 to 639 do begin
        sintabel[i]:=round(sin(v)*32767);
        v:=v+vadd;
    end;
end;

procedure SetColors;
var
    i : integer;
begin
    for i:=0 to 64 do setRGB(i,i,i,i);
    SetRGB(floor_color,13,13,13);
    for i:=0 to (HEIGHT DIV 4) do
        SetRGB(sky_color+i,3,6+(i DIV 1),38+(i DIV 2));
    SetRGB(yellow1_color,58,52,3);
    SetRGB(yellow2_color,63,57,7);
    SetRGB(red1_color,63,7,7);
    SetRGB(red2_color,60,3,3);
end;

procedure InitKasser;
var
    tempstr : string;
    fil : text;
    i,j,k : integer;
begin
    {$I-}
    Assign(fil,ParamStr(1));
    Reset(fil);
    {$I+}
    if (IOresult<>0) then begin
        writeln;
        writeln('ERROR: File not found...');
        writeln;
        halt;
    end;
    for i:=-MAX to MAX do begin
        {$I-}
        ReadLn(fil,tempstr);
        {$I+}
        if (IOresult<>0) OR (length(tempstr)<21) then begin
            Close(fil);
            writeln;
            writeln('ERROR: Wrong file format...');
            writeln;
            halt;
        end;
        plade[i]:=tempstr;
    end;
    Close(fil);

    count:=0;
    for i:=-MAX to MAX do begin
        k:=1;
        for j:=1 to 21 do
            if (plade[i][j]='*') then begin
                new(alle_kasser[i,k]);
                with (alle_kasser[i,k]^) do begin
                    z:=(i*BOXZ*2)+BOXZ;
                    x:=((j-(MAX+1))*BOXX*2)+BOXX;
                    f1:=TRUE; f2:=TRUE; f3:=TRUE; f4:=TRUE;
                    if (i<>-MAX) AND (plade[i-1][j]='*') then f1:=FALSE;
                    if (j<>1) AND (plade[i][j-1]='*') then f2:=FALSE;
                    if (i<>MAX) AND (plade[i+1][j]='*') then f3:=FALSE;
                    if (j<>21) AND (plade[i][j+1]='*') then f4:=FALSE;
                end;
                inc(count);
                inc(k);
            end;
        alle_kasser[i,k]:=NIL;
    end;
    dec(count);
end;


procedure InitDemo;
var
    i : integer;
begin
    new(dispbuffer);
    ClearWholeScreen;
    SetColors;
    SetupSinus;

    InitMouse;
    MouseOff;
    SetMousePos(160,100);

    i:=-MAX;
    while (plade[i,2]<>' ') do inc(i);
    worldx:=-i*BOXX*2;
    dec(worldx,BOXX);
    worldz:=(-MAX)*BOXX*2;
    inc(worldz,BOXX);

    v:=270;
    speedx:=-18;
    speedz:=0;
end;

procedure UninitDemo;
var
    i,j : integer;
begin
    for i:=-MAX to MAX do begin
        j:=1;
        while (alle_kasser[i,j]<>NIL) do begin
            Dispose(alle_kasser[i,j]);
            inc(j);
        end;
    end;
    Dispose(dispbuffer);
end;


(*------------------------------------------------*)

procedure SwapDisplay;
var
    temp : word;
begin
    temp:=display3;
    display3:=display2;
    display2:=display1;
    display1:=temp;
    SetAddress(Ptr(SEGA000,display2));
end;


(*------------------------------------------------*)
(*-          MOVE PLAYER AROUND A BIT            -*)
(*------------------------------------------------*)

function WhereX(x : integer) : integer;
begin
    WhereX:=longdiv(-x+(MAX*BOXX*2),BOXX*2)-MAX;
end;

function WhereZ(z : integer) : integer;
begin
    WhereZ:=longdiv(-z+(MAX*BOXX*2),BOXX*2)-MAX;
end;

procedure MovePlayer;
var
    x,y,z : integer;
    newWhereX, newWhereZ : integer;
    oldworldx, oldworldz : integer;
    cx,cz : longint;
    lb,rb : boolean;
begin
    fillchar(paint,sizeof(paint),0);

    if (MOUSE_CONTROL) then begin
        MouseInfo(x,y,lb,rb);
        SetMousePos(160,100);
        x:=(x-160) DIV 4;
        v:=(v+x) AND 511;
    end
    else v:=(v+2) AND 511;

    vinkel1:=sintabel[v];
    vinkel2:=sintabel[v+128];

    if (MOUSE_CONTROL) AND (rb OR lb) then begin
        RotateKasse(speedx,speedz,x,z);
        oldworldx:=worldx;
        oldworldz:=worldz;
        inc(worldx,z);
        inc(worldz,x);
        newWhereX:=WhereX(worldz);
        newWhereZ:=WhereZ(worldx);
        {bumped into a wall?}
        if (plade[WhereX(worldz),newWhereZ+MAX+1]='*') then begin
            worldx:=oldworldx;
            worldz:=oldworldz;
        end
        else
        if (plade[WhereX(worldz-40),newWhereZ+MAX+1]='*') then begin
            worldx:=oldworldx;
            worldz:=oldworldz;
        end
        else
        if (plade[WhereX(worldz+40),newWhereZ+MAX+1]='*') then begin
            worldx:=oldworldx;
            worldz:=oldworldz;
        end
        else
        if (plade[newWhereX,WhereZ(worldx-40)+MAX+1]='*') then begin
            worldx:=oldworldx;
            worldz:=oldworldz;
        end
        else
        if (plade[newWhereX,WhereZ(worldx+40)+MAX+1]='*') then begin
            worldx:=oldworldx;
            worldz:=oldworldz;
        end;
    end;
end;


(*------------------------------------------------*)
(*-             ROTATE ALL THAT STUFF            -*)
(*------------------------------------------------*)

procedure RotateKasse(x,z : integer; VAR rx,rz : integer); assembler;
asm
    mov    ax,x
    mov    cx,ax
    imul    WORD PTR vinkel2
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,z
    imul    WORD PTR vinkel1
    add    ax,ax
    adc    dx,dx
    sub   bx,dx
    les    di,rx
    mov    [es:di],bx
    mov    ax,cx
    imul    WORD PTR vinkel1
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,z
    imul    WORD PTR vinkel2
    add    ax,ax
    adc    dx,dx
    add    bx,dx
    les    di,rz
    mov    [es:di],bx
end;

procedure RotateCoord(x,y,z : integer; VAR rx,ry,rz : integer); assembler;
asm
    mov    ax,x
    mov    cx,ax
    imul    WORD PTR vinkel2
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,z
    imul    WORD PTR vinkel1
    add    ax,ax
    adc    dx,dx
    sub   bx,dx
    les    di,rx
    mov    [es:di],bx
    mov    ax,cx
    imul    WORD PTR vinkel1
    add    ax,ax
    adc    dx,dx
    mov    bx,dx
    mov    ax,z
    imul    WORD PTR vinkel2
    add    ax,ax
    adc    dx,dx
    add    bx,dx
    les    di,rz
    mov    [es:di],bx
    les    di,ry
    mov    ax,y
    mov    [es:di],ax
end;


(*------------------------------------------------*)
(*-                 CALC STUFF                   -*)
(*------------------------------------------------*)

procedure CalcSlope(x1,y1,z1,x2,y2,z2 : integer; color : integer);
const
    zcut = 35;
var
    n : integer;
    temp : integer;
    y,dely : longint;
    swapped : boolean;
begin
    {cut z-coord}
    swapped:=FALSE;
    if (z1>z2) then asm
        mov    ax,x1
        xchg    ax,x2
        mov   x1,ax
        mov    ax,y1
        xchg    ax,y2
        mov   y1,ax
        mov    ax,z1
        xchg    ax,z2
        mov    z1,ax
        mov    swapped,TRUE
    end;
    if (z2<ZCUT) then exit;
    if (z1<=ZCUT) then begin
        z1:=z2-z1;
        temp:=ZCUT-z2;
        if (z1=0) then z1:=1;
        x1:=longdiv(longmul(temp,x2-x1),z1)+x2;
        y1:=longdiv(longmul(temp,y2-y1),z1)+y2;
        z1:=ZCUT;
    end;

    {calc perspektive}
    asm
        mov    cx,z1            {(x1 shl 8) DIV z1}
        mov    ax,x1
        cwd
        mov    dl,ah
        mov    ah,al
        xor    al,al
        idiv    cx
        add    ax,MIDDLE_X
        mov    x1,ax
        mov    ax,y1            {(y1 shl 8) DIV z1}
        cwd
        mov    dl,ah
        mov    ah,al
        xor    al,al
        idiv    cx
        mov    y1,ax

        mov    cx,z2
        mov    ax,x2
        cwd
        mov    dl,ah
        mov    ah,al
        xor    al,al
        idiv    cx
        add    ax,MIDDLE_X
        mov    x2,ax
        mov    ax,y2
        cwd
        mov    dl,ah
        mov    ah,al
        xor    al,al
        idiv    cx
        mov    y2,ax
    end;

    if (swapped) then asm
        mov    ax,x1
        xchg    ax,x2
        mov   x1,ax
        mov    ax,y1
        xchg    ax,y2
        mov   y1,ax
        {z-coord is not swapped this time... no longed needed!}
    end;

    {is the face is shown at all...}
    if (x1>x2) then exit;
    n:=x2-x1;
    {cut borders if nessesary}
    if (x1>=320) OR (x2<=0) OR (n<1) then exit;
    if (x1<0) AND (x1<>x2) then begin
        inc(n,x1);
        y1:=-longdiv(longmul(y1-y2,x2),(x1-x2))+y2;
        x1:=0;
    end;
    if (x2>=320) AND (x2<>x1) then begin
        n:=(320-x1);
        y2:=longdiv(longmul(y2-y1,319-x1),(x2-x1))+y1;
        x2:=319;
    end;
    {prepare calc slope...}
    if (n<1) then exit;
    dely := (y2-y1) * ($10000 DIV (n));
    y := y1 * (1 shl 16);
    asm
        mov    ax,ds
        mov    es,ax
        lea    di,tabel
        mov    si,n
        mov    ax,WORD PTR y+2
        mov    dx,WORD PTR y
        mov    cx,WORD PTR dely
        mov    bx,WORD PTR dely+2
        cld
@loop1:
        add    dx,cx
        adc    ax,bx
        stosw
        dec    si
        jnz    @loop1


        mov    ax,ds
        mov    es,ax
        lea    si,paint
        mov    ax,x1
        shl    ax,1
        add    si,ax
        lea    di,tabel
        mov    bx,color
        mov    dx,2
        mov    cx,n
@insert:
        lodsw
        and    ax,ax
        jnz    @occupied
        mov    ax,[di]
        cmp    ax,1
        jge    @below
        mov    ax,1
@below:
        cmp    ax,MIDDLE_Y
        jle    @above
        mov    ax,MIDDLE_Y
@above:
        mov    [si-2],ax {insert height}
        mov    [si+TYPE(booktabel)-2],bx {insert color}
@occupied:
        add    di,dx
        loop    @insert
    end;
end;


procedure SortKasseListe(antal : integer);
{highly optimized, eh?}
var
    j : integer;
    done : boolean;
begin
    j:=0;
    asm
@sortloop1:
        lea    bx,synlige_kasser
        mov    done,TRUE
        mov    cx,antal
        sub    cx,j
        jcxz    @donesorting

        les    si,[bx]
        mov    dx,[es:si+kassetype.newz]
@sortloop2:
        mov    di,dx
        add    bx,TYPE pKasse
        les    si,[bx]
        mov    dx,[es:si+kassetype.newz]
        cmp    di,dx
        jle    @noswap

        mov    ax,es
        xchg    si,[bx-4]
        xchg    ax,[bx-2]
        mov    [bx],si
        mov    [bx+2],ax
        mov    es,ax
        mov    dx,di
        mov    done,FALSE
@noswap:
        dec    cx
        jnz    @sortloop2
        inc    j
        cmp    done,FALSE
        je        @sortloop1
@donesorting:
    end;
end;


(*------------------------------------------------*)
(*-             DRAW ENTIRE SCREEN               -*)
(*------------------------------------------------*)

procedure DrawScreen(i : integer); assembler;
var
    temp,lowheight,
    n : integer;
asm
    push    ds

    {fill out bitplane with colors}
    mov    ax,ds
    mov    es,ax
    lea    di,paint
    mov    ax,i
    shl    ax,1
    add    di,ax

    lds    si,dispbuffer
    mov    dx,WIDTH*2
    mov    n,80
    cld
@loop:
    push    si
    mov    ax,[es:di]

    {fill sky}
    mov    temp,ax
    mov    cx,MIDDLE_Y
    sub    cx,ax
    mov    Lowheight,cx
    jcxz    @no1
    mov    al,SKY_COLOR
    mov    bx,$0001
    test    cx,1
    jz        @calcfill1
    mov    [si],al
    add    si,WIDTH
    mov    bx,$0100
    inc    al
    dec    cx
    jcxz    @no1
@calcfill1:
    shr    cx,1
@fill1:
    mov    [si],al
    add    al,bl
    mov    [si+WIDTH],al
    add    al,bh
    add    si,dx
    loop    @fill1
@no1:

    {fill walls}
    mov    cx,temp
    shl    cx,1
    jcxz    @no2
    mov    al,[es:di+TYPE(booktabel)]
    test    cx,3
    jz        @calcfill2
    mov    ah,cl
    and    ah,3
    mov    [si],al
    add    si,WIDTH
    dec    cx
    dec    ah
    jz        @calcfill2
    mov    [si],al
    add    si,WIDTH
    dec    cx
    dec    ah
    jz        @calcfill2
    mov    [si],al
    add    si,WIDTH
    dec    cx
@calcfill2:
    shr    cx,2
    jcxz    @no2
    mov    bx,WIDTH*3
    mov    dx,WIDTH*4
@fill2:
    mov    [si],al
    mov    [si+(WIDTH)],al
    mov    [si+(WIDTH*2)],al
    mov    [si+bx],al
    add    si,dx
    loop    @fill2
    mov    dx,WIDTH*2
@no2:

    {fill floor}
    mov    cx,LowHeight
    jcxz    @no3
    mov    al,FLOOR_COLOR
    mov    bx,WIDTH
    test    cx,1
    jz        @calcfill3
    mov    [si],al
    add    si,bx
    dec    cx
    jcxz    @no3
@calcfill3:
    shr    cx,1
@fill3:
    mov    [si],al
    mov    [si+bx],al
    add    si,dx
    loop    @fill3
@no3:

@done:
    add    di,8
    pop    si
    inc    si
    dec    n
    jnz    @loop


    {copy this bitplane to screen}
    mov    ax,SEG @DATA
    mov    ds,ax
    mov    es,SEGA000
    mov    di,display1
    add    di,WIDTH*30 {window offset}
    lds    si,dispbuffer
    mov    cx,(WIDTH*HEIGHT)/4
    rep; DB LONG; movsw;
    pop    ds
end;


(*------------------------------------------------*)
(*-             SELECT VISIBLE KASSER            -*)
(*------------------------------------------------*)

procedure CopyKasser1(p : pointer); assembler;
{get kasser in current row and rows beside}
asm
    push    ds
    mov    ax,ds
    mov    es,ax
    lea    di,kasser
    mov    ax,antal
    shl    ax,1
    shl    ax,1
    add    di,ax
    mov    bx,antal
    lds    si,p
    cld
@copy:
    lodsw
    mov    dx,ax
    lodsw
    and    ax,ax
    jnz    @docopy
    and    dx,dx
    jz        @nomore
@docopy:
    xchg    ax,dx
    stosw
    mov    ax,dx
    stosw
    inc    bx
    jmp    NEAR PTR @copy
@nomore:
    mov    antal,bx
    pop    ds
end;

procedure CopyKasser2(p : pointer; zmin,zmax : integer); assembler;
{get kasser in current coloum and the ones beside it}
asm
    push    ds
    mov    ax,ds
    mov    es,ax
    lea    di,kasser
    mov    ax,antal
    shl    ax,1
    shl    ax,1
    add    di,ax
    mov    cx,zmin
    lds    si,p
    mov    cx,ds    {get pointer-segment}
    cld
@copy:
    lodsw
    mov    bx,ax
    lodsw
    and    ax,ax
    jnz    @docopy
    and    bx,bx
    jz        @nomore
@docopy:
    mov    ds,ax
    mov    dx,[bx+kassetype.x]
    cmp    dx,zmin
    jle    @notthis
    cmp    dx,zmax
    jge    @notthis
    xchg    ax,bx
    stosw
    mov    ax,bx
    stosw
    inc    es:antal
@notthis:
    mov    ds,cx
    jmp    NEAR PTR @copy
@nomore:
    pop    ds
end;

procedure GetSomeKasser;
var
    x,x_min,x_max,
    z,z_min,z_max : integer;
    i,j : integer;
begin
    antal:=0;

    x:=WhereZ(worldz);
    x_min:=x-2;
    x_max:=x+2;
    for i:=-MAX to MAX do
        if (i>=x_min) AND (i<=x_max) then CopyKasser1(@alle_kasser[i,1]);

    z:=-worldx;
    z_min:=z-(BOXX*4)-1;
    z_max:=z+(BOXX*4)-1;
    for i:=-MAX to MAX do if (i<x_min) OR (i>x_max) then
        CopyKasser2(@alle_kasser[i,1],z_min,z_max);

    dec(antal);
end;


procedure GetSomeLessKasser;
var
    i,j : integer;
begin
    j:=-1;
    for i:=0 to antal do with kasser[i]^ do begin
        RotateKasse(x+worldx,z+worldz,newx,newz);
        if (newz>-BOXX) AND (newx>-3200) AND (newx<3200) then begin
            inc(j);
            synlige_kasser[j]:=kasser[i];
        end;
    end;
    antal:=j;
end;


procedure DrawEmAll;
var
    i : integer;
    color : integer;
    x1,y1,z1,
    x2,y2,z2,
    x3,y3,z3,
    x4,y4,z4 : integer;
begin
    for i:=0 to antal do with synlige_kasser[i]^ do begin
        RotateCoord(worldx+x-BOXX,BOXY,worldz+z-BOXZ, x1,y1,z1);
        RotateCoord(worldx+x+BOXX,BOXY,worldz+z-BOXZ, x2,y2,z2);
        RotateCoord(worldx+x+BOXX,BOXY,worldz+z+BOXZ, x3,y3,z3);
        RotateCoord(worldx+x-BOXX,BOXY,worldz+z+BOXZ, x4,y4,z4);
        color:=longdiv(MAXZ-newz,128);
        if (f1) then CalcSlope(x1,y1,z1,x2,y2,z2,color);
        if (f4) then CalcSlope(x2,y2,z2,x3,y3,z3,color);
        if (f3) then CalcSlope(x3,y3,z3,x4,y4,z4,color);
        if (f2) then CalcSlope(x4,y4,z4,x1,y1,z1,color);
    end;
end;

(*------------------------------------------------*)


procedure RunOnce;
label
    none;
var
    i : integer;
begin
    SwapDisplay;
    while retraces=0 do ;
    retraces:=0;
{$IFDEF DEBUG}
    i:=retraces;
    while i=retraces do ;
    SetRGB(0,30,0,0);
{$ENDIF}
    MovePlayer;

    GetSomeKasser;
    if (antal<0) then goto none;
    GetSomeLessKasser;
    if (antal<0) then goto none;
    SortKasseListe(antal);
    DrawEmAll;
none:
    for i:=0 to 3 do begin
        SetBitplanes(1 shl i);
        DrawScreen(i);
    end;

    if (Key='H') then DrawBigHelpScreen;
    if (Key in ['1'..'9']) then speedx:=-((ord(Key)-48) shl 2);

{$IFDEF DEBUG}
    SetRGB(0,0,0,0);
{$ENDIF}
end;

begin
    SystemCheck;
    InitKasser;
    {IntroText};
    OpenScreen;
    Screen_Off;
    InitDemo;
    SetAllInterrupts;
    Screen_On;
    repeat RunOnce until Key='e';
    RestoreAllInterrupts;
    UninitDemo;
    CloseScreen;
end.